home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / i686-linux-thread-multi / Sys / Syslog.pm < prev   
Text File  |  2006-04-25  |  17KB  |  605 lines
  1. package Sys::Syslog;
  2. require 5.006;
  3. require Exporter;
  4. require DynaLoader;
  5. use Carp;
  6. use strict;
  7.  
  8. our @ISA = qw(Exporter DynaLoader);
  9. our @EXPORT = qw(openlog closelog setlogmask syslog);
  10. our @EXPORT_OK = qw(setlogsock);
  11. our $VERSION = '0.06';
  12.  
  13. # it would be nice to try stream/unix first, since that will be
  14. # most efficient. However streams are dodgy - see _syslog_send_stream
  15. my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
  16. if ($^O =~ /^(freebsd|linux)$/) {
  17.     @connectMethods = grep { $_ ne 'udp' } @connectMethods;
  18. }
  19. my @defaultMethods = @connectMethods;
  20. my $syslog_path = undef;
  21. my $transmit_ok = 0;
  22. my $current_proto = undef;
  23. my $failed = undef;
  24. my $fail_time = undef;
  25. our ($connected, @fallbackMethods, $syslog_send, $host);
  26.  
  27. use Socket ':all';
  28. use Sys::Hostname;
  29.  
  30. =head1 NAME
  31.  
  32. Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
  33.  
  34. =head1 SYNOPSIS
  35.  
  36.     use Sys::Syslog;                          # all except setlogsock, or:
  37.     use Sys::Syslog qw(:DEFAULT setlogsock);  # default set, plus setlogsock
  38.  
  39.     setlogsock $sock_type;
  40.     openlog $ident, $logopt, $facility;       # don't forget this
  41.     syslog $priority, $format, @args;
  42.     $oldmask = setlogmask $mask_priority;
  43.     closelog;
  44.  
  45. =head1 DESCRIPTION
  46.  
  47. Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
  48. Call C<syslog()> with a string priority and a list of C<printf()> args
  49. just like C<syslog(3)>.
  50.  
  51. Syslog provides the functions:
  52.  
  53. =over 4
  54.  
  55. =item openlog $ident, $logopt, $facility
  56.  
  57. I<$ident> is prepended to every message.  I<$logopt> contains zero or
  58. more of the words I<pid>, I<ndelay>, I<nowait>.  The cons option is
  59. ignored, since the failover mechanism will drop down to the console
  60. automatically if all other media fail.  I<$facility> specifies the
  61. part of the system to report about, for example LOG_USER or LOG_LOCAL0:
  62. see your C<syslog(3)> documentation for the facilities available in
  63. your system.
  64.  
  65. B<You should use openlog() before calling syslog().>
  66.  
  67. =item syslog $priority, $format, @args
  68.  
  69. If I<$priority> permits, logs I<($format, @args)>
  70. printed as by C<printf(3V)>, with the addition that I<%m>
  71. is replaced with C<"$!"> (the latest error message).
  72.  
  73. If you didn't use openlog() before using syslog(), syslog will try to
  74. guess the I<$ident> by extracting the shortest prefix of I<$format>
  75. that ends in a ":".
  76.  
  77. =item setlogmask $mask_priority
  78.  
  79. Sets log mask I<$mask_priority> and returns the old mask.
  80.  
  81. =item setlogsock $sock_type [$stream_location] (added in 5.004_02)
  82.  
  83. Sets the socket type to be used for the next call to
  84. C<openlog()> or C<syslog()> and returns TRUE on success,
  85. undef on failure.
  86.  
  87. A value of 'unix' will connect to the UNIX domain socket (in some
  88. systems a character special device) returned by the C<_PATH_LOG> macro
  89. (if your system defines it), or F</dev/log> or F</dev/conslog>,
  90. whatever is writable.  A value of 'stream' will connect to the stream
  91. indicated by the pathname provided as the optional second parameter.
  92. (For example Solaris and IRIX require 'stream' instead of 'unix'.)
  93. A value of 'inet' will connect to an INET socket (either tcp or udp,
  94. tried in that order) returned by getservbyname(). 'tcp' and 'udp' can
  95. also be given as values. The value 'console' will send messages
  96. directly to the console, as for the 'cons' option in the logopts in
  97. openlog().
  98.  
  99. A reference to an array can also be passed as the first parameter.
  100. When this calling method is used, the array should contain a list of
  101. sock_types which are attempted in order.
  102.  
  103. The default is to try tcp, udp, unix, stream, console.
  104.  
  105. Giving an invalid value for sock_type will croak.
  106.  
  107. =item closelog
  108.  
  109. Closes the log file.
  110.  
  111. =back
  112.  
  113. Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
  114.  
  115. =head1 EXAMPLES
  116.  
  117.     openlog($program, 'cons,pid', 'user');
  118.     syslog('info', '%s', 'this is another test');
  119.     syslog('mail|warning', 'this is a better test: %d', time);
  120.     closelog();
  121.  
  122.     syslog('debug', 'this is the last test');
  123.  
  124.     setlogsock('unix');
  125.     openlog("$program $$", 'ndelay', 'user');
  126.     syslog('notice', 'fooprogram: this is really done');
  127.  
  128.     setlogsock('inet');
  129.     $! = 55;
  130.     syslog('info', 'problem was %m'); # %m == $! in syslog(3)
  131.  
  132.     # Log to UDP port on $remotehost instead of logging locally
  133.     setlogsock('udp');
  134.     $Sys::Syslog::host = $remotehost;
  135.     openlog($program, 'ndelay', 'user');
  136.     syslog('info', 'something happened over here');
  137.  
  138. =head1 SEE ALSO
  139.  
  140. L<syslog(3)>
  141.  
  142. =head1 AUTHOR
  143.  
  144. Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
  145. E<lt>F<larry@wall.org>E<gt>.
  146.  
  147. UNIX domain sockets added by Sean Robinson
  148. E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce 
  149. E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
  150.  
  151. Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
  152. E<lt>F<tom@compton.nu>E<gt>.
  153.  
  154. Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
  155.  
  156. Failover to different communication modes by Nick Williams
  157. E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
  158.  
  159. =cut
  160.  
  161. sub AUTOLOAD {
  162.     # This AUTOLOAD is used to 'autoload' constants from the constant()
  163.     # XS function.
  164.     
  165.     my $constname;
  166.     our $AUTOLOAD;
  167.     ($constname = $AUTOLOAD) =~ s/.*:://;
  168.     croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
  169.     my ($error, $val) = constant($constname);
  170.     if ($error) {
  171.     croak $error;
  172.     }
  173.     no strict 'refs';
  174.     *$AUTOLOAD = sub { $val };
  175.     goto &$AUTOLOAD;
  176. }
  177.  
  178. bootstrap Sys::Syslog $VERSION;
  179.  
  180. our $maskpri = &LOG_UPTO(&LOG_DEBUG);
  181.  
  182. sub openlog {
  183.     our ($ident, $logopt, $facility) = @_;  # package vars
  184.     our $lo_pid = $logopt =~ /\bpid\b/;
  185.     our $lo_ndelay = $logopt =~ /\bndelay\b/;
  186.     our $lo_nowait = $logopt =~ /\bnowait\b/;
  187.     return 1 unless $lo_ndelay;
  188.     &connect;
  189. } 
  190.  
  191. sub closelog {
  192.     our $facility = our $ident = '';
  193.     &disconnect;
  194. } 
  195.  
  196. sub setlogmask {
  197.     my $oldmask = $maskpri;
  198.     $maskpri = shift;
  199.     $oldmask;
  200. }
  201.  
  202. sub setlogsock {
  203.     my $setsock = shift;
  204.     $syslog_path = shift;
  205.     &disconnect if $connected;
  206.     $transmit_ok = 0;
  207.     @fallbackMethods = ();
  208.     @connectMethods = @defaultMethods;
  209.     if (ref $setsock eq 'ARRAY') {
  210.     @connectMethods = @$setsock;
  211.     } elsif (lc($setsock) eq 'stream') {
  212.     unless (defined $syslog_path) {
  213.         my @try = qw(/dev/log /dev/conslog);
  214.         if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
  215.         unshift @try, &_PATH_LOG;
  216.             }
  217.         for my $try (@try) {
  218.         if (-w $try) {
  219.             $syslog_path = $try;
  220.             last;
  221.         }
  222.         }
  223.         carp "stream passed to setlogsock, but could not find any device"
  224.         unless defined $syslog_path;
  225.         }
  226.     unless (-w $syslog_path) {
  227.         carp "stream passed to setlogsock, but $syslog_path is not writable";
  228.         return undef;
  229.     } else {
  230.         @connectMethods = ( 'stream' );
  231.     }
  232.     } elsif (lc($setsock) eq 'unix') {
  233.         if (length _PATH_LOG() && !defined $syslog_path) {
  234.         $syslog_path = _PATH_LOG();
  235.         @connectMethods = ( 'unix' );
  236.         } else {
  237.         carp 'unix passed to setlogsock, but path not available';
  238.         return undef;
  239.         }
  240.     } elsif (lc($setsock) eq 'tcp') {
  241.     if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
  242.         @connectMethods = ( 'tcp' );
  243.     } else {
  244.         carp "tcp passed to setlogsock, but tcp service unavailable";
  245.         return undef;
  246.     }
  247.     } elsif (lc($setsock) eq 'udp') {
  248.     if (getservbyname('syslog', 'udp')) {
  249.         @connectMethods = ( 'udp' );
  250.     } else {
  251.         carp "udp passed to setlogsock, but udp service unavailable";
  252.         return undef;
  253.     }
  254.     } elsif (lc($setsock) eq 'inet') {
  255.     @connectMethods = ( 'tcp', 'udp' );
  256.     } elsif (lc($setsock) eq 'console') {
  257.     @connectMethods = ( 'console' );
  258.     } else {
  259.         carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
  260.     }
  261.     return 1;
  262. }
  263.  
  264. sub syslog {
  265.     my $priority = shift;
  266.     my $mask = shift;
  267.     my ($message, $whoami);
  268.     my (@words, $num, $numpri, $numfac, $sum);
  269.     our $facility;
  270.     local($facility) = $facility;    # may need to change temporarily.
  271.  
  272.     croak "syslog: expecting argument \$priority" unless $priority;
  273.     croak "syslog: expecting argument \$format"   unless $mask;
  274.  
  275.     @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
  276.     undef $numpri;
  277.     undef $numfac;
  278.     foreach (@words) {
  279.     $num = &xlate($_);        # Translate word to number.
  280.     if (/^kern$/ || $num < 0) {
  281.         croak "syslog: invalid level/facility: $_";
  282.     }
  283.     elsif ($num <= &LOG_PRIMASK) {
  284.         croak "syslog: too many levels given: $_" if defined($numpri);
  285.         $numpri = $num;
  286.         return 0 unless &LOG_MASK($numpri) & $maskpri;
  287.     }
  288.     else {
  289.         croak "syslog: too many facilities given: $_" if defined($numfac);
  290.         $facility = $_;
  291.         $numfac = $num;
  292.     }
  293.     }
  294.  
  295.     croak "syslog: level must be given" unless defined($numpri);
  296.  
  297.     if (!defined($numfac)) {    # Facility not specified in this call.
  298.     $facility = 'user' unless $facility;
  299.     $numfac = &xlate($facility);
  300.     }
  301.  
  302.     &connect unless $connected;
  303.  
  304.     $whoami = our $ident;
  305.  
  306.     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
  307.     $whoami = $1;
  308.     $mask = $2;
  309.     } 
  310.  
  311.     unless ($whoami) {
  312.     ($whoami = getlogin) ||
  313.         ($whoami = getpwuid($<)) ||
  314.         ($whoami = 'syslog');
  315.     }
  316.  
  317.     $whoami .= "[$$]" if our $lo_pid;
  318.  
  319.     $mask =~ s/(?<!%)%m/$!/g;
  320.     $mask .= "\n" unless $mask =~ /\n$/;
  321.     $message = sprintf ($mask, @_);
  322.  
  323.     $sum = $numpri + $numfac;
  324.     my $buf = "<$sum>$whoami: $message\0";
  325.  
  326.     # it's possible that we'll get an error from sending
  327.     # (e.g. if method is UDP and there is no UDP listener,
  328.     # then we'll get ECONNREFUSED on the send). So what we
  329.     # want to do at this point is to fallback onto a different
  330.     # connection method.
  331.     while (scalar @fallbackMethods || $syslog_send) {
  332.     if ($failed && (time - $fail_time) > 60) {
  333.         # it's been a while... maybe things have been fixed
  334.         @fallbackMethods = ();
  335.         disconnect();
  336.         $transmit_ok = 0; # make it look like a fresh attempt
  337.         &connect;
  338.         }
  339.     if ($connected && !connection_ok()) {
  340.         # Something was OK, but has now broken. Remember coz we'll
  341.         # want to go back to what used to be OK.
  342.         $failed = $current_proto unless $failed;
  343.         $fail_time = time;
  344.         disconnect();
  345.     }
  346.     &connect unless $connected;
  347.     $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
  348.     if ($syslog_send) {
  349.         if (&{$syslog_send}($buf)) {
  350.         $transmit_ok++;
  351.         return 1;
  352.         }
  353.         # typically doesn't happen, since errors are rare from write().
  354.         disconnect();
  355.     }
  356.     }
  357.     # could not send, could not fallback onto a working
  358.     # connection method. Lose.
  359.     return 0;
  360. }
  361.  
  362. sub _syslog_send_console {
  363.     my ($buf) = @_;
  364.     chop($buf); # delete the NUL from the end
  365.     # The console print is a method which could block
  366.     # so we do it in a child process and always return success
  367.     # to the caller.
  368.     if (my $pid = fork) {
  369.     our $lo_nowait;
  370.     if ($lo_nowait) {
  371.         return 1;
  372.     } else {
  373.         if (waitpid($pid, 0) >= 0) {
  374.             return ($? >> 8);
  375.         } else {
  376.         # it's possible that the caller has other
  377.         # plans for SIGCHLD, so let's not interfere
  378.         return 1;
  379.         }
  380.     }
  381.     } else {
  382.         if (open(CONS, ">/dev/console")) {
  383.         my $ret = print CONS $buf . "\r";
  384.         exit ($ret) if defined $pid;
  385.         close CONS;
  386.     }
  387.     exit if defined $pid;
  388.     }
  389. }
  390.  
  391. sub _syslog_send_stream {
  392.     my ($buf) = @_;
  393.     # XXX: this only works if the OS stream implementation makes a write 
  394.     # look like a putmsg() with simple header. For instance it works on 
  395.     # Solaris 8 but not Solaris 7.
  396.     # To be correct, it should use a STREAMS API, but perl doesn't have one.
  397.     return syswrite(SYSLOG, $buf, length($buf));
  398. }
  399. sub _syslog_send_socket {
  400.     my ($buf) = @_;
  401.     return syswrite(SYSLOG, $buf, length($buf));
  402.     #return send(SYSLOG, $buf, 0);
  403. }
  404.  
  405. sub xlate {
  406.     my($name) = @_;
  407.     return $name+0 if $name =~ /^\s*\d+\s*$/;
  408.     $name = uc $name;
  409.     $name = "LOG_$name" unless $name =~ /^LOG_/;
  410.     $name = "Sys::Syslog::$name";
  411.     # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
  412.     my $value = eval { no strict 'refs'; &$name };
  413.     defined $value ? $value : -1;
  414. }
  415.  
  416. sub connect {
  417.     @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
  418.     if ($transmit_ok && $current_proto) {
  419.     # Retry what we were on, because it's worked in the past.
  420.     unshift(@fallbackMethods, $current_proto);
  421.     }
  422.     $connected = 0;
  423.     my @errs = ();
  424.     my $proto = undef;
  425.     while ($proto = shift(@fallbackMethods)) {
  426.     no strict 'refs';
  427.     my $fn = "connect_$proto";
  428.     $connected = &$fn(\@errs) if defined &$fn;
  429.     last if ($connected);
  430.     }
  431.  
  432.     $transmit_ok = 0;
  433.     if ($connected) {
  434.     $current_proto = $proto;
  435.         my($old) = select(SYSLOG); $| = 1; select($old);
  436.     } else {
  437.     @fallbackMethods = ();
  438.     foreach my $err (@errs) {
  439.         carp $err;
  440.     }
  441.     croak "no connection to syslog available";
  442.     }
  443. }
  444.  
  445. sub connect_tcp {
  446.     my ($errs) = @_;
  447.     unless ($host) {
  448.     require Sys::Hostname;
  449.     my($host_uniq) = Sys::Hostname::hostname();
  450.     ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
  451.     }
  452.     my $tcp = getprotobyname('tcp');
  453.     if (!defined $tcp) {
  454.     push(@{$errs}, "getprotobyname failed for tcp");
  455.     return 0;
  456.     }
  457.     my $syslog = getservbyname('syslog','tcp');
  458.     $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
  459.     if (!defined $syslog) {
  460.     push(@{$errs}, "getservbyname failed for tcp");
  461.     return 0;
  462.     }
  463.  
  464.     my $this = sockaddr_in($syslog, INADDR_ANY);
  465.     my $that = sockaddr_in($syslog, inet_aton($host));
  466.     if (!$that) {
  467.     push(@{$errs}, "can't lookup $host");
  468.     return 0;
  469.     }
  470.     if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
  471.     push(@{$errs}, "tcp socket: $!");
  472.     return 0;
  473.     }
  474.     setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
  475.     setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
  476.     if (!CORE::connect(SYSLOG,$that)) {
  477.     push(@{$errs}, "tcp connect: $!");
  478.     return 0;
  479.     }
  480.     $syslog_send = \&_syslog_send_socket;
  481.     return 1;
  482. }
  483.  
  484. sub connect_udp {
  485.     my ($errs) = @_;
  486.     unless ($host) {
  487.     require Sys::Hostname;
  488.     my($host_uniq) = Sys::Hostname::hostname();
  489.     ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
  490.     }
  491.     my $udp = getprotobyname('udp');
  492.     if (!defined $udp) {
  493.     push(@{$errs}, "getprotobyname failed for udp");
  494.     return 0;
  495.     }
  496.     my $syslog = getservbyname('syslog','udp');
  497.     if (!defined $syslog) {
  498.     push(@{$errs}, "getservbyname failed for udp");
  499.     return 0;
  500.     }
  501.     my $this = sockaddr_in($syslog, INADDR_ANY);
  502.     my $that = sockaddr_in($syslog, inet_aton($host));
  503.     if (!$that) {
  504.     push(@{$errs}, "can't lookup $host");
  505.     return 0;
  506.     }
  507.     if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
  508.     push(@{$errs}, "udp socket: $!");
  509.     return 0;
  510.     }
  511.     if (!CORE::connect(SYSLOG,$that)) {
  512.     push(@{$errs}, "udp connect: $!");
  513.     return 0;
  514.     }
  515.     # We want to check that the UDP connect worked. However the only
  516.     # way to do that is to send a message and see if an ICMP is returned
  517.     _syslog_send_socket("");
  518.     if (!connection_ok()) {
  519.     push(@{$errs}, "udp connect: nobody listening");
  520.     return 0;
  521.     }
  522.     $syslog_send = \&_syslog_send_socket;
  523.     return 1;
  524. }
  525.  
  526. sub connect_stream {
  527.     my ($errs) = @_;
  528.     # might want syslog_path to be variable based on syslog.h (if only
  529.     # it were in there!)
  530.     $syslog_path = '/dev/conslog'; 
  531.     if (!-w $syslog_path) {
  532.     push(@{$errs}, "stream $syslog_path is not writable");
  533.     return 0;
  534.     }
  535.     if (!open(SYSLOG, ">" . $syslog_path)) {
  536.     push(@{$errs}, "stream can't open $syslog_path: $!");
  537.     return 0;
  538.     }
  539.     $syslog_send = \&_syslog_send_stream;
  540.     return 1;
  541. }
  542.  
  543. sub connect_unix {
  544.     my ($errs) = @_;
  545.     if (length _PATH_LOG()) {
  546.     $syslog_path = _PATH_LOG();
  547.     } else {
  548.         push(@{$errs}, "_PATH_LOG not available in syslog.h");
  549.     return 0;
  550.     }
  551.     my $that = sockaddr_un($syslog_path);
  552.     if (!$that) {
  553.     push(@{$errs}, "can't locate $syslog_path");
  554.     return 0;
  555.     }
  556.     if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
  557.     push(@{$errs}, "unix stream socket: $!");
  558.     return 0;
  559.     }
  560.     if (!CORE::connect(SYSLOG,$that)) {
  561.         if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
  562.         push(@{$errs}, "unix dgram socket: $!");
  563.         return 0;
  564.     }
  565.         if (!CORE::connect(SYSLOG,$that)) {
  566.         push(@{$errs}, "unix dgram connect: $!");
  567.         return 0;
  568.     }
  569.     }
  570.     $syslog_send = \&_syslog_send_socket;
  571.     return 1;
  572. }
  573.  
  574. sub connect_console {
  575.     my ($errs) = @_;
  576.     if (!-w '/dev/console') {
  577.     push(@{$errs}, "console is not writable");
  578.     return 0;
  579.     }
  580.     $syslog_send = \&_syslog_send_console;
  581.     return 1;
  582. }
  583.  
  584. # to test if the connection is still good, we need to check if any
  585. # errors are present on the connection. The errors will not be raised
  586. # by a write. Instead, sockets are made readable and the next read
  587. # would cause the error to be returned. Unfortunately the syslog 
  588. # 'protocol' never provides anything for us to read. But with 
  589. # judicious use of select(), we can see if it would be readable...
  590. sub connection_ok {
  591.     return 1 if (defined $current_proto && $current_proto eq 'console');
  592.     my $rin = '';
  593.     vec($rin, fileno(SYSLOG), 1) = 1;
  594.     my $ret = select $rin, undef, $rin, 0;
  595.     return ($ret ? 0 : 1);
  596. }
  597.  
  598. sub disconnect {
  599.     close SYSLOG;
  600.     $connected = 0;
  601.     $syslog_send = undef;
  602. }
  603.  
  604. 1;
  605.